perm filename CYCOMC[1,LMM]1 blob sn#031683 filedate 1973-03-27 generic text, type T, neo UTF8
(COMMENT IO FUNCTIONS)

  (DE PRINRAD (L)
      (PROG (N)
            (PRINT L)
            (SETQ N (NUMNODES L))
            (PRINRAD0 N)
            (PRINRAD1 NIL (FOR NEW I := (N 1 -1)
                               XLIST I)
                      L)
            (PRINRADOFF L)))
)))))))))))))))))

  (DE NUMNODES (RAD)
      (PLUS (FOR NEW R IN (ATTACHEDRADS RAD)
                 PLUS
                 (TIMES (CDR R)
                        (NUMNODES (CAR R))))
            (IF (NULL (CENTER RAD))
                THEN 0 ELSEIF (ATOM (CENTER RAD))
                THEN 1 ELSEIF (NOT (STRUCTURE? (RADSTRUC (CENTER RAD))))
                THEN 1 ELSE (LENGTH (NODES (RADSTRUC (CENTER RAD)))))))
)))))))))))))))))


  (DE PRINRAD1 (EFF AA RAD)
    (PROG (CENT ATTACHED J X TTABLE)
      (SETQ CENT (CENTER RAD))
      (SETQ ATTACHED (CLEXPAND (ATTACHEDRADS RAD)))
      (RETURN (IF (NOT CENT) THEN
                  (PRINRAD1 (CADR AA)
                            (CONS (CAR AA)
                                  (PRINRAD1 (CAR AA)
                                            (CDR AA)
                                            (CAR ATTACHED)))
                            (CADR ATTACHED))
            ELSEIF(OR (ATOM CENT)
                      (NOT (EQ (ID (RADSTRUC CENT))
                               (QUOTE STRUC))))
             THEN (SETQ X (CDR AA))
                  (FOR NEW R IN ATTACHED DO (SETQ J (CONS (CAR X) J))
                                (SETQ X (PRINRAD1 (CAR AA) X R)))
                  (PRINENTRY (CAR AA) CENT (IF EFF THEN (CONS EFF J) ELSE J))
                  X
	     ELSE (SETQ X (IF (NOT EFF) THEN AA
			   ELSE (SETQ TTABLE (LIST (LIST (AFFLINK CENT)
                                                         (CAR AA)
                                                          EFF)))
                                (CDR AA)))
                  (FOR NEW N IN (NODES (RADSTRUC CENT))
                       WHEN
                       (NOT (EQUAL N (AFFLINK CENT)))
                       DO
                       (SETQ TTABLE (CONS (LIST N (CAR X))
                                          TTABLE))
                       (SETQ X (CDR X)))
                  (FOR NEW NLIST IN (CUFFLINKS CENT)
                       FOR NEW C IN NLIST AS NEW CT IS
                       (LMASSOC C TTABLE NIL)
                       DO
                       (NCONC CT (LIST (CAR X)))
                       (SETQ X (PRINRAD1 (CAR CT)
                                         X
                                         (CAR ATTACHED)))
                       (SETQ ATTACHED (CDR ATTACHED)))
                  (PRINCTAB (CTABLE (RADSTRUC CENT))
                            TTABLE)
                  X))))
)))))))))))))))))

  (DE
    PRINCTAB
    (CTAB TTABLE)
    (FOR NEW CT IN CTAB AS NEW CPRIME IS (LMASSOC (NODENUM CT)
                                                TTABLE NIL)
         DO
         (PRINENTRY (CAR CPRIME)
                    (ATOMTYPE MARKERS CT)
                    (APPEND (CDR CPRIME)
                            (FOR NEW Y IN (NBRS CT)
                                 IF
                                 (NOT (EQ Y (QUOTE FV)))
                                 XLIST
                                 (CAR (LMASSOC Y TTABLE NIL)))))))
)))))))))))))))))

  (DE PRINRAD0 (N)
      (PROG NIL 
            (QUOTE (VERBOS NIL))
            (QUOTE (OTLL 72))
            (SETQ XLATN 0)
            (QUOTE (TTAB 1))
            (PRINNUM 5 N)
            (TERPRI)))
)))))))))))))))))

  (DE PRINENTRY (NODE TYPE NBRS)
      (PROG NIL (QUOTE (TTAB 1))
            (PRINNUM 3 NODE)
            (QUOTE (XTAB 1))
            (IF (ATOM TYPE)
                THEN
                (PRIN1 TYPE)
                ELSE
                (PRIN1 (QUOTE X))
                (PRIN1 (SETQ XLATN (ADD1 XLATN)))
                (SETQ XLATETABLE (CONS (CONS XLATN TYPE)
                                       XLATETABLE)))
            (QUOTE (TTAB 9))
            (FOR NEW N IN NBRS DO (PRINNUM 3 N))
            (TERPRI)))
)))))))))))))))))

  (DE PRINNUM (W N)
      (PROG2 (QUOTE (XTAB (DIFFERENCE W (WIDTH N))))
             (PRIN1 N)))
)))))))))))))))))

  (DE WIDTH (N)
      (FOR NEW X IN (QUOTE ((99999 6)
                            (9999 5)
                            (999 4)
                            (99 3)
                            (9 2)
                            (0 1)))
           UNTIL
           (GREATERP N (CAR X))
           PROG2
           (CADR X)))
)))))))))))))))))

  (DE PRINRADOFF (L)
      (PROG NIL (QUOTE (TTAB 1))
            (PRIN1 (QUOTE STRUCTURE=))
            (PRINT L)
            (FOR NEW X IN XLATETABLE DO (PRIN1 (QUOTE X))
                 (PRIN1 (CAR X))
                 (PRIN1 (QUOTE =))
                 (PRINT (CDR X)))
            (QUOTE (TTAB 1))
            (PRINT (QUOTE END*))
            (QUOTE (OTLL 133))
            (SETQ XLATETABLE NIL)))
)))))))))))))))))